perm filename EUCLID.FAI[GEO,BGB] blob
sn#001346 filedate 1972-10-28 generic text, type T, neo UTF8
00100 TITLE EUCLID - EUCLIDEAN TRANSFORMATIONS - JULY 1972.
00200 COMMENT /
00400 ...after Euclid of Alexandria, fl. c.300 BC, Greek Geometer.
00500 TRANSLATE (Q,R);
00600 ROTATE (Q,R);
00700 DILATE (Q,R);
00800 REFLECT (Q,R);
00900 /
01000
01200 EXTERN ECW,ECCW,OTHER
01300 EXTERN BODY,FCW,FCCW,VCW,VCCW
01400
01500 ;NORMALIZE AN ORIENTATION MATRIX.
01600 ;NORM(LOC)
01700 SUBR(NORM)
01800 BEGIN NORM
01900 EXTERN SQRT;CLOBBERS AC1 THRU AC4.
02000 ;PICK'EM UP.
02100 SAVAC(15)↔LIMZ 5↔SLAP ARG1↔BLT 15
02200 ; R ← SQRT(A↑2+B↑2+C↑2); A←A/R; B←B/R; C←C/R;
02300 FOR Q IN (5,10,13){
02400 LAC 1,Q↔FMPR 1,1
02500 LAC 1+Q↔FMPR↔FADR 1,0
02600 LAC 2+Q↔FMPR↔FADR 1,0
02700 CAMN 1,[1.0]↔GO .+6
02800 PUSH P,1↔PUSHJ P,SQRT
02900 FDVR Q,1↔FDVR Q+1,1↔FDVR Q+2,1}
03000 ;PUT'EM DOWN.
03100 CDR ARG1↔LAC 1,↔SLIM 5↔BLT 8(1)
03200 GETAC(15)↔RET1↔VAR
03300 BEND
00100 ;ORTHOGONIZE AN ORIENTATION MATRIX.
00200 ;IT IS ASSUMED THAT THE ROW VECTORS ARE UNIT VECTORS.
00300 SUBR(ORTHO)
00400 BEGIN ORTHO
00500 X←0 ↔ Y←1 ↔ Z←2 ;ADDRESS DISPLACEMENTS.
00600 Q←9 ↔ R←13 ↔ A←14 ↔ B←15 ;ACCUMULATORS.
00700 SAVAC(15)
00800 SETOM FLG# ;FIRST TIME THRU FLAG.
00900 ;PLACE THE MATRIX INTO THE FIRST NINE ACCUMULATORS.
01000 L0: LAC R,ARG1↔SLIMZ Q,IX(R)↔BLT Q,KZ
01100
01200 ;DOT EACH ROW VECTOR INTO THE NEXT ROW.
01300 FMPR IX,JX ↔FMPR IY,JY ↔FMPR IZ,JZ ↔FADR IX,IY↔FADR IX,IZ
01400 FMPR JX,KX ↔FMPR JY,KY ↔FMPR JZ,KZ ↔FADR JX,JY↔FADR JX,JZ
01500 FMPR KX,IX(R)↔FMPR KY,IY(R)↔FMPR KZ,IZ(R)↔FADR KX,KY↔FADR KX,KZ
01600
01700 ;TAKE ABSOLUTE VALUES AND FIND THE WORST TOTAL COSINE.
01800 MOVMS IX↔MOVMS JX↔MOVMS KX
01900 LAC Q,KX↔FADR KX,JX↔FADR JX,IX↔FADR Q,IX↔EXCH Q,JX↔SETZM SIGN#
02000 LIMZ 1,IX(R)↔LIMZ 2,JX(R)↔LIMZ 3,KX(R) ;GET ROW POINTERS.
02100 CAML Q,IX↔GO .+4↔EXCH 2,1↔EXCH Q,IX↔SETCMM SIGN ;GET 2 BIGGER THAN 1.
02200 CAML KX,Q↔GO .+4↔EXCH 3,2↔EXCH KX,Q↔SETCMM SIGN ;GET 3 BIGGER THAN 2.
02300 CAMG KX,[0.00001]↔GO L1 ;GOOD ENUF FOR GOVERNMENT WORK.
02400
02500 ;STRAIGHTEN UP THE WORST VECTOR.
02600 LAC A,Y(1)↔FMPR A,Z(2)
02700 LAC B,Y(2)↔FMPR B,Z(1)↔FSBR A,B↔DAC A,X(3)
02800 LAC A,X(2)↔FMPR A,Z(1)
02900 LAC B,X(1)↔FMPR B,Z(2)↔FSBR A,B↔DAC A,Y(3)
03000 LAC A,X(1)↔FMPR A,Y(2)
03100 LAC B,X(2)↔FMPR B,Y(1)↔FSBR A,B↔DAC A,Z(3)
03200 SKIPE SIGN↔GO[MOVNS X(3)↔MOVNS Y(3)↔MOVNS Z(3)↔GO .+1]
03300 SKIPN FLG↔GO L1↔SETZM FLG↔GO L0
03400 L1: GETAC(15)↔POP1J
03500 LIT
03600 BEND
00100 ;MATRIX CROSS PRODUCT. S cross Q → R.
00200 ;CLOBBERS 0,1 AND EXPECTS ARGUMENTS IN AC S,Q & R.
00300 ;92 words - 550 useconds.
00400 CRUX: 0
00500 BEGIN CRUX
00600 ACCUMULATORS{S,Q,R}
00700 DEFINE ADR(I,J)<3*I+J-4>
00800 FOR I←1,3{
00900 FOR J←1,3{
01000 LAC ADR(I,1)(S)↔FMPR ADR(1,J)(Q)↔LAC 1,
01100 LAC ADR(I,2)(S)↔FMPR ADR(2,J)(Q)↔FADR 1,
01200 LAC ADR(I,3)(S)↔FMPR ADR(3,J)(Q)↔FADR 1,
01300 DAC 1,ADR(I,J)(R)
01400 }}↔GO@CRUX
01500 BEND
00100 ;ROTDEL(REF,DEL,AXIS,DELTA)
00200 ;Setup a rotation DEL-MATRIX in DEL,
00300 ;with respect to the frame of referance REF,
00400 ;about AXIS 0-X, 1-Y, 2-Z by DETLA radians.
00500 SUBR(ROTDEL)
00600 BEGIN ROTDEL
00700 EXTERN SIN,COS
00800 ACCUMULATORS{S,Q,R,REF,DEL,AXIS}
00900 DAC 12,SAV12
01000 ;SET DEL LOCUS TO REF LOCUS AND CLEAR DEL ORIENTATION.
01100 LAC REF,ARG4↔LAC DEL,ARG3
01200 SLIMZ XWC(REF)↔LIM XWC(DEL)↔BLT ZWC(DEL)
01300 SETZM IX(DEL)↔SLIMZ IX(DEL)↔LIM IY(DEL)↔BLT KZ(DEL)
01400
01500 ;PLACE SINE(DELTA) AND COSINE(DELTA) INTO DEL'S ORIENTATION.
01600 SETZM SINE#↔FLIM 1,1.0↔CAR AXIS,ARG2↔JUMPN AXIS,.+6
01700 PUSH P,ARG1↔PUSHJ P,SIN↔DAC 1,SINE#
01800 PUSH P,ARG1↔PUSHJ P,COS
01900 LAC DEL,ARG3
02000 DAC 1,IX(DEL)↔DAC 1,JY(DEL)↔DAC 1,KZ(DEL)
02100 FLIM 0,1.0↔LAC 1,SINE
02200 CDR AXIS,ARG2↔CAILE AXIS,2↔SETZ AXIS
02300 LSH AXIS,2↔GO .+1(AXIS)
02400 DAC IX(DEL)↔DAC 1,KY(DEL)↔DACN 1,JZ(DEL)↔GO L ;CCW ABOUT I.
02500 DAC JY(DEL)↔DAC 1,IZ(DEL)↔DACN 1,KX(DEL)↔GO L ;CCW ABOUT J.
02600 DAC KZ(DEL)↔DAC 1,JX(DEL)↔DACN 1,IY(DEL)↔L: ;CCW ABOUT K.
02700
02800 ;(transpose(REF)cross(DEL cross REF)) → DEL.
02900 ;BRING 'EM FROM THE REFRAM AND HIT 'EM WITH THE DEL.
03000 LAC DEL,ARG3↔LAC REF,ARG4
03100 SLIMZ IX(REF)↔LIM IX+REF↔BLT KZ+REF ;A TERRIBLE PUN ON REF.
03200 LAC S,ARG3↔LAC Q,ARG4↔LIMZ R,TMP↔JSR CRUX
03300
03400 ;SHRINK AND/OR MIRROR 'EM.
03500 L1: CAR 0,ARG2 ;GET AXIS SELECT BITS.
03600 JUMPE L4 ;THERE AIN'T ANY.
03700 LAC 1,ARG1
03800 TRNN 4↔GO L2↔FMPRM 1,IX(R)↔FMPRM 1,IY(R)↔FMPRM 1,IZ(R)
03900 L2: TRNN 1↔GO L3↔FMPRM 1,JX(R)↔FMPRM 1,JY(R)↔FMPRM 1,JZ(R)
04000 L3: TRNN 2↔GO L4↔FMPRM 1,KX(R)↔FMPRM 1,KY(R)↔FMPRM 1,KZ(R)
04100
04200 ;TRANSPOSE THE REFRAME AND MAP'EM BACK FROM WHERE THEY CAME.
04300 L4: EXCH 6,10↔EXCH 7,13↔EXCH 12,14
04400 LIMZ S,5↔LIMZ Q,TMP↔LAC R,ARG3↔JSR CRUX
04500 LAC 12,SAV12
04600 RET4
04700 SAV12: 0
04800 TMP: BLOCK 9
04900 BEND
00100 ;TRANSLATE(Q,R).
00200 SUBR(TRANSLATE)
00300 BEGIN TRANSL
00400 DEFINE TRAN.{FADRM X,XWC(V)↔FADRM Y,YWC(V)↔FADRM Z,ZWC(V)}
00500 Q←1
00600 ACCUMULATORS{B,F,E,V,X,Y,Z,N,S12,R,E0}
00700 CDR R,ARG1
00800 LAC X,XWC(R)↔LAC Y,YWC(R)↔LAC Z,ZWC(R)
00900 LAC Q,ARG2↔LAC(1)
01000 FOR @$ Qε{BFEV}{
01100 TLNE(Q$BIT)↔GO Q$TRAN}
01200 LOCOR V,Q↔TRAN.↔RET2;CAMERA CASE.
01300
01400 ;BODY TRANSLATION.
01500 BTRAN: LAC B,Q↔FCNT 0,B↔CAIN 0,1↔GO L2; ONE FACED BODY.
01550 LAC V,B↔SLIMZ(VBIT);INITIAL BODY VERTEX.
01600 L1: PVT V,V↔TDNN(V)↔GO L2;SKIP WHEN VERTEX.
01700 TRAN.↔GO L1;TRANSLATE A VERTEX OF THE BODY.
01800 L2: LOCOR V,B↔SKIPN V↔GO L3;BODY LOCUS.
01900 TRAN.
02000
02100 ;...AND ALL THE PARTS OF THIS BODY.
02200 L3: PART N,B↔JUMPL N,.+6
02300 PUSH P,B↔PUSH P,N↔PUSH P,R↔PUSHJ P,TRANSLATE↔POP P,B
02400 CDR N,(P)↔CAIE N,.-2↔RET2
02500 COPART B,B↔SKIPL V,B↔GO L1↔RET2
02600
02700 ;FACE TRANSLATION.
02800 FTRAN: LAC F,Q↔NCNT N,F↔PED E0,F↔LAC E,E0; PICK'EM UP.
02900 JUMPE E0,[PFACE B,F↔PVT V,B↔TRAN.↔RET2]; VERTEX FACE.
03000 JUMPL N,L4↔AOS N↔MOVNS N
03100 PCW 0,E↔CAME 0,E↔GO L5; TEST FOR WIRE.
03200 L4: SETQ(V,{VCW,E,F})↔TRAN.; WIRE OR SHEET'S 1ST VERTEX.
03300 L5: SETQ(V,{VCCW,E,F}); GET VERTEX.
03400 TRAN.↔SETQ(0,{ECCW,E,F}); MOVE IT & GET EDGE.
03500 CAMN 0,E↔RET2; END OF WIRE.
03600 LAC E,0↔CAMN E,E0↔RET2; END OF FACE.
03700 AOJL N,L5↔RET2; END OF SHEET.
03800
03900 ;EDGE TRANSLATION.
04000 ETRAN: LAC E,Q
04100 PVT V,E↔TRAN.
04200 NVT V,E↔TRAN.
04300 RET2
04400
04500 ;VERTEX TRANSLATION.
04600 VTRAN: LAC V,Q
04700 TRAN.
04800 RET2
04900 BEND
00100 ;ROTATION'S INNER MOST SUBROUTINE.
00200 ;EXPECTS ARGUMENTS IN V AND R, CLOBBERS 0,1,X,Y,Z.
00300 ; 36 words - 200 useconds.
00400 ROTOR: 0
00500 BEGIN ROTOR
00600 ACCUMULATORS{B,F,E,V,X,Y,Z,N,S12,R,E0}
00700
00800 LAC X,XWC(V)↔ FSBR X,XWC(R);
00900 LAC Y,YWC(V)↔ FSBR Y,YWC(R);
01000 LAC Z,ZWC(V)↔ FSBR Z,ZWC(R);
01100
01200 DEFINE ROTAT $(Q){
01300 LAC 0,X↔ FMPR 0,Q$X(R)
01400 LAC 1,Y↔ FMPR 1,Q$Y(R)↔ FADR 0,1
01500 LAC 1,Z↔ FMPR 1,Q$Z(R)↔ FADR 0,1}
01600
01700 ROTAT(I)↔ FADR XWC(R)↔ DAC XWC(V)
01800 ROTAT(J)↔ FADR YWC(R)↔ DAC YWC(V)
01900 ROTAT(K)↔ FADR ZWC(R)↔ DAC ZWC(V)
02000
02100 GO @ROTOR
02200 BEND
00100 ;DILATE(Q,R)
00200 SUBR(DILATE)
00300 SETOM ROTFLG↔GO ROTATE+1
00400
00500 ;REFLECT(Q,R)
00600 SUBR(REFLECT)
00700 LIMZ 1↔DAC ROTFLG↔GO ROTATE+1
00800 ROTFLG: 0
00900
01000 ;ROTATION(Q,R).
01100 SUBR(ROTATE)
01200 BEGIN ROTATE
01300 Q←1
01400 DEFINE ROTA.{JSR ROTOR}
01500 ACCUMULATORS{B,F,E,V,X,Y,Z,N,S12,R,E0}
01600
01700 SETZM ROTFLG; PURE ROTATION.
01800 CDR R,ARG1
01900 LAC Q,ARG2↔LAC(Q)
02000 FOR @$ Qε{BFEV}{
02100 TLNE(Q$BIT)↔GO Q$ROTA}
02200
02300 ;CAMERA CASE.
02400 LOCOR V,Q↔ROTA.
02500 PUSH P,XWC(R)↔PUSH P,YWC(R)↔PUSH P,ZWC(R)
02600 SETZM XWC(R)↔SETZM YWC(R)↔SETZM ZWC(R)
02700 PUSH P,V
02800 REPEAT 3,{ADDI V,3↔ROTA.↔}
02900 PUSHJ P,NORM
03000 POP P,ZWC(R)↔POP P,YWC(R)↔POP P,XWC(R)
03100 RET2
00100 ;BODY ROTATION.
00200 BROTA: LAC B,Q↔FCNT 0,B↔CAIN 0,1↔GO L2; ONE FACED BODY.
00250 LAC V,B;INITIAL BODY VERTEX.
00300 L1: PVT V,V↔SLIMZ(VBIT)↔TDNN(V)↔GO L2;SKIP WHEN VERTEX.
00400 ROTA.↔GO L1;ROTATE A VERTEX OF THE BODY.
00500 L2: LOCOR V,B↔SKIPN V↔GO L3;BODY LOCUS.
00600 ROTA.
00700 PUSH P,XWC(R)↔PUSH P,YWC(R)↔PUSH P,ZWC(R)
00800 SETZM XWC(R)↔SETZM YWC(R)↔SETZM ZWC(R)
00900 PUSH P,V
01000 REPEAT 3,{ADDI V,3↔ROTA.↔}
01100 PUSHJ P,NORM↔ADD P,[XWD 1,1]↔PUSHJ P,ORTHO
01200 POP P,ZWC(R)↔POP P,YWC(R)↔POP P,XWC(R)
01300 ;...AND ALL THE PARTS OF THIS BODY.
01310 L3: PART N,B↔JUMPL N,.+6
01320 PUSH P,B↔PUSH P,N↔PUSH P,R↔PUSHJ P,ROTATE↔POP P,B
01330 CDR N,(P)↔CAIE N,.-2↔RET2
01340 COPART B,B↔SKIPL V,B↔GO L1↔RET2
01900
02000 ;FACE ROTATION.
02100 FROTA: LAC F,Q↔NCNT N,F↔PED E0,F↔LAC E,E0; PICK'EM UP.
02200 JUMPE E0,[PFACE B,F↔PVT V,B↔ROTA.↔RET2]; VERTEX FACE.
02300 JUMPL N,L4↔AOS N↔MOVNS N
02400 PCW 0,E↔CAME 0,E↔GO L5; TEST FOR WIRE.
02500 L4: SETQ(V,{VCW,E,F})↔ROTA.; WIRE OR SHEET'S 1ST VERTEX.
02600 L5: SETQ(V,{VCCW,E,F}); GET VERTEX.
02700 ROTA.↔SETQ(0,{ECCW,E,F}); MOVE IT & GET EDGE.
02800 CAMN 0,E↔RET2; END OF WIRE.
02900 LAC E,0↔CAMN E,E0↔RET2; END OF FACE.
03000 AOJL N,L5↔RET2; END OF SHEET.
03100
03200 ;EDGE ROTATION.
03300 EROTA: LAC E,Q
03400 PVT V,E↔ROTA.
03500 NVT V,E↔ROTA.
03600 RET2
03700
03800 ;VERTEX ROTATION.
03900 VROTA: LAC V,Q
04000 ROTA.
04100 RET2
04200 BEND
00100 ;SETUP A EUCLIDEAN TRANSFORMATION MATRIX IN LOCOR Q.
00200 ;OP = 0-TRANSLATION, 1-ROTATION, 2-DILATION, 3-REFLECTION.
00300 ;AXIS = 0-X, 1-Y, 2-Z, (3-X).
00400 ;AXECNT = 0 & 1 for AXIS, 2 for ¬AXIS, 3 for all AXES.
00500
00600 ;EUCLID(Q,OPAXCNT,DELTA).
00700 SUBR(EUCLID)
00800 BEGIN EUCLID
00900 ACCUMULATORS{Q,REF,DELTA}
01000 CDR Q,ARG3
01100 LAC DELTA,ARG1
01200
01300 ;UNPACK OPAXCNT AND INSURE ITS LEGALITY.
01400 LAC ARG2
01500 LDB 1,[POINT 3,0,29]↔DAC 1,OP#
01600 LDB 1,[POINT 3,0,32]↔CAIN 1,3↔SETZ 1,↔DAC 1,AXIS#
01700 ANDI 7↔SKIPN↔LIMZ 1↔DAC AXECNT#
01800
01900 ;SETUP DILATION AXIS SELECT BITS 4-X,1-Y,2-Z IN LEFT HALF OF AXIS.
02000 SKIPN 1↔TRO 1,4
02100 CAIN 2↔TRC 1,7↔CAIN 3↔TRO 1,7↔DIP 1,AXIS
02200
02300 ;TRANSLATION.
02400 SKIPE OP↔GO L1↔CDR 1,AXIS
02500 GO .+1(1)↔GO TX↔GO TY↔GO TZ
02600 TX: LAC IX(Q)↔FMPR DELTA↔DAC XWC(Q)
02700 LAC IY(Q)↔FMPR DELTA↔DAC YWC(Q)
02800 LAC IZ(Q)↔FMPR DELTA↔DAC ZWC(Q)
02900 RET3
03000 TY: LAC JX(Q)↔FMPR DELTA↔DAC XWC(Q)
03100 LAC JY(Q)↔FMPR DELTA↔DAC YWC(Q)
03200 LAC JZ(Q)↔FMPR DELTA↔DAC ZWC(Q)
03300 RET3
03400 TZ: LAC KX(Q)↔FMPR DELTA↔DAC XWC(Q)
03500 LAC KY(Q)↔FMPR DELTA↔DAC YWC(Q)
03600 LAC KZ(Q)↔FMPR DELTA↔DAC ZWC(Q)
03700 RET3
03800
03900 ;COPY Q-FRAME INTO REF AND CALL ROTDEL.
04000 L1: LIMZ REF,REFRAME
04100 SLIMZ XWC(Q)↔LIM XWC(REF)↔BLT KZ(REF)
04110 LAC OP↔CAIGE 2↔ZIP AXIS
04200 CALL ROTDEL,REF,Q,AXIS,DELTA
04300 RET3
04400 BLOCK 3↔REFRAME: BLOCK 9
04500 BEND
04600
04700 END